;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8; Lowercase:T; Readtable:CL -*-

;Note: This is a commonlisp file!

;;; Ultra-simple stepper for lisp-machine.
;;; Wins with multiple values
;;; Does not attempt to win with editor top level

;NOTES:
; The way it decides whether it needs to reprint the form when showing
; you the values is pretty kludgey right now.  Can it check the cursorpos
; or ask itself whether it typed anything or something?
;
; Would like to be able to evaluate and/or substitute in atoms and forms
; without having to break first.
;
; Would like to be able to type c-A and have it stop after evaluating the
; args, before calling the function.
;
; Raid registers
;
; Hook up to DDT?
;
; If an error happens, user should be able to throw back into the stepper.

(defvar *step-level* nil
  "Depth within STEP-EVALHOOK, minus one, within call to STEP")
(defvar *step-array* nil
  "Holds forms to evaluate, indexed by *STEP-LEVEL* value.")
(defvar *step-apply-p-array* nil
  "Holds the APPLY-P flag for each level, indexed by *STEP-LEVEL* value.")
(defvar *step-max* nil
  "Do not tell user about evaluations with *STEP-LEVEL* deeper than this.")
(defvar *step-form* nil
  "Form to be or just evaluated, in STEP command loop")
(defvar *step-value* nil
  "First value just computed.  May be changed in a breakpoint.")
(defvar *step-values* nil
  "List of values just computed.  May be changed in a breakpoint.")

(defvar *step-auto* nil)
;if non NIL, simulate cntrl-n at step-cmdr.
; normal printout produced unless NO-PRINT.
;  User's program can turn on auto mode by
;  (si:*step-auto-on &optional (mode 'no-print))
; and (si:*step-auto-off) to reable stepping.

;;; Main entry point.
(defun step (form &optional *step-auto* &aux (*step-level* -1) (*step-max* 0)
             (*step-array* (make-array #o200))
             (*step-apply-p-array* (make-array #o200)))
  "Evaluate FORM with stepping.  It stops before and after each subexpression.
Type the Help key when you are in the stepper for a list of stepper commands."
  (binding-interpreter-environment (())
    (step-evalhook form ())))

;;; This is for TRACE, mainly.  The idea is to do an apply,
;;; stepping under it but not showing the user the apply itself.
(defun step-apply (fcn args &aux (*evalhook* #'step-hook))
  (apply fcn args))

;;; Main entry point.
(defun step-hook (form &optional environment &aux *step-auto* (*step-level* -1) (*step-max* 0)
                  (*step-array* (make-array #o200))
                  (*step-apply-p-array* (make-array #o200)))
  (step-evalhook form environment))

;;; Check for macros, they are treated specially.
(defun step-macro-form-p (form environment)
  (and (consp form)
       (symbolp (car form))
       (macro-in-environment-p (car form) environment)))

(defun step-auto-on (&optional (mode 'no-print))
  (setq *step-auto* mode))

(defun step-auto-off ()
  (setq *step-auto* nil))

;;; Print a form, suitably indented, marked, and truncated to one line.
(defun step-print-form (form level apply-p environment)
  (terpri)
  (do ((n (* 2 level) (1- n)))
      ((= n 0))
    (write-char #\sp))
  (write-char (cond (apply-p #\)
                    ((step-macro-form-p form environment) #\)
                    (t #\)))
  (write-char #\sp)
  (if apply-p
      (progn (print-truncated (function-name (car form)) 75.)
             (princ ": ")
             (print-elements-truncated (cdr form) 90. 75.))
      (print-truncated form 75.)))

;;; Print whatever is necessary, read a command, set special variables
;;; and return how to proceed:  eval (just eval), evalhook (recurse), more options later.
;;; If calling for eval, *step-values* is nil, otherwise calling for return.
(defun step-cmdr (form values print-form-p apply-p environment)
  (declare (special apply-p))
  (prog (ch ch1
         (*standard-input* *query-io*)
         (*standard-output* *query-io*))
        (if *step-auto*
            (if (eq *step-auto* 'no-print)
                (progn (setq *step-max* (1+ *step-level*)) (return 'evalhook))))
        (and print-form-p
             (step-print-form form *step-level* apply-p environment))
     pv (do ((l values (cdr l))
             (ch #\ #\))
            ((null l))
          (terpri-if-insufficient-space 80.)
          (write-char #\sp) (write-char ch) (write-char #\sp)
          (print-truncated (car l) 98.))        ;Several windows lose if this is 100.
     rd (setq ch1 (if *step-auto* #\c-N (read-char *standard-input*)))
        (setq ch (char-upcase ch1))
        (case ch
          (#\call (break "from stepper."))
          (#\space (setq *step-max* *step-level*) (return 'eval))
          (#\c-U (setq *step-max* (max 0 (1- *step-level*))) (return 'eval))
          (#\c-N (setq *step-max* (1+ *step-level*)) (return 'evalhook))
          (#\c-X (setq *step-max* -1) (return 'eval))
          (#\c-A
           (unless apply-p
             (setq *step-max* (1+ *step-level*)) (return 'applyhook)))
          (#\c-B
           (break "from stepper")
           (setf (aref *step-array* *step-level*) *step-form*)
           (setf (aref *step-apply-p-array* *step-level*) apply-p)
           (setq ch 0)
           (go redis1))
          (#\c-E
           (ed)
           (setq ch 10.)
           (go redisplay))
          ((#\Clear-Screen #\c-L)
           (setq ch 10.)
           (go redisplay))
          (#\m-L
           (setq ch 10.)
           (go redis1))
          (#\c-m-L
           (setq ch *step-level*)
           (go redisplay))
          ((#\c-G #\c-T)
           (setq ch (if (eql ch #\c-G) #'grind-top-level #'print))
           (cond ((null values) (funcall ch form))
                 ((do ((l values (cdr l)))
                      ((null l))
                    (funcall ch (car l)))))
           (go rd))
          (#\HELP
           (sys:with-help-stream (help-str :label "Stepper help")
             (terpri help-str)
             (princ
               (if (null *step-values*)
                   (if apply-p
                       "You are about to apply the above function to the above arguments."
                       "You are about to evaluate the above form.")
                 (if apply-p
                     "You have applied a function to arguments
and are about to return the above values."
                     "You have evaluated a form and are about to return the above values."))
               help-str)
             (terpri help-str)
             (princ
"Commands are single characters, usually control, which don't echo:

    C-N     Proceed to next thing evaled.
    <space> Proceed to next thing evaled at same level.
    C-A     Eval the args without stepping; stop before applying the function.
    C-U     Proceed to first thing up one level.
    C-X     Continue without further stepping.
    C-E     Escape to editor.
    C-T     Retype current form in full.
    C-G     Grind current form.
    C-B     Enter breakpoint, with the following variables bound:
                SI::*STEP-FORM* is the form, SI::*STEP-VALUES* is the list of values,
                SI::*STEP-VALUE* is the first value.  If you change these, it wins.
    C-L
    <form>  Clear and show last 10. forms.
    M-L     Just show last 10. forms (don't clear).
    C-M-L   Clear and show all forms.
    <any LISP form>
            Will be read and evaluated, and values printed.

Magic flags preceding output:

       Ordinary LISP form
       About to apply a function
       Macro
       Values
       Separates multiple values
"
        help-str))
           (setq ch 0)
           ;; No need to redisplay if with-help-stream used a separate window.
           (if (typep *terminal-io* 'tv:sheet) (go rd))
           (go redis1))
          ((zerop (char-bits ch1))
           (unread-char ch1)
           (catch-error-restart ((sys:abort error) "Back to STEP command level.")
             (print
               (eval-abort-trivial-errors
                 (multiple-value-bind (sexp flag)
                     (with-input-editing (*standard-input* '((:full-rubout :full-rubout)
                                                             (:prompt " Eval: ")))
                       (si:read-for-top-level *standard-input* nil nil nil))
                   (when (eq flag ':full-rubout)
                     (go rd))
                   sexp))))
           (terpri)
           (setq ch 0)
           (go redis1))
          (t
           (beep)
           (go rd)))
     redisplay
        (send *standard-output* :clear-window)
     redis1
        (do ((i (max 0 (- *step-level* ch)) (1+ i)))
            ((> i *step-level*))
          (step-print-form (aref *step-array* i) i (aref *step-apply-p-array* i) environment))
        (go pv)))

;;; This is evalhooked in in place of EVAL.  Works by calling step-cmdr
;;; to let the user see what's going on and say what to do, then continues
;;; evaluation using either EVAL or EVALHOOK based on what the user typed.
;;; Has special hair for macros and for atoms.
(defun step-evalhook (*step-form* &optional environment)
  (binding-interpreter-environment (environment)
    (let ((*step-level* (1+ *step-level*))
          (*step-value*) (*step-values*)
          tem val)
      (tagbody
          (when ( *step-level* (array-length *step-array*))
            (adjust-array-size *step-array* (+ #o100 *step-level*))
            (adjust-array-size *step-apply-p-array* (+ #o100 *step-level*)))
       mc (setf (aref *step-array* *step-level*) *step-form*)
          (setf (aref *step-apply-p-array* *step-level*) nil)
          (cond ((atom *step-form*)
                 (setq *step-values* (list (eval1 *step-form*)))
                 (setq tem 'atom)
                 (go rl))
                (( *step-level* *step-max*)
                 (setq tem (step-cmdr *step-form* nil t nil environment)))
                (t (setq tem 'eval)))
          (cond ((step-macro-form-p *step-form* environment)
                 (setq *step-form* (macroexpand-1 *step-form* environment))
                 (go mc))
                ((eq tem 'eval)
                 (setq *step-values* (multiple-value-list
                                       (evalhook *step-form* nil nil environment))))
                ((eq tem 'evalhook)
                 (setq *step-values* (multiple-value-list
                                       (evalhook *step-form* #'step-evalhook nil environment))))
                ((eq tem 'applyhook)
                 (setq *step-values* (multiple-value-list
                                       (evalhook *step-form* nil #'step-applyhook environment))))
                ((ferror nil "Unknown function ~S" tem)))
       rl (setq *step-value* (setq val (car *step-values*)))
          (if ( *step-level* *step-max*)
              (setq tem (step-cmdr *step-form* *step-values* (neq tem 'eval) nil environment))
            (setq tem 'eval))
          (and (neq *step-value* val) (return-from step-evalhook *step-value*))
       rt (cond ((null (cdr *step-values*))
                 (return-from step-evalhook (car *step-values*)))
                (t
                 (return-next-value (car *step-values*))
                 (setq *step-values* (cdr *step-values*))
                 (go rt)))))))

(defun step-applyhook (function args &optional environment
                       &aux (*step-form* (cons function args)))
  (binding-interpreter-environment (environment)
    (let ((*step-level* (1+ *step-level*))
          (*step-value*) (*step-values*)
          tem val)
      (tagbody
          (when ( *step-level* (array-length *step-array*))
            (adjust-array-size *step-array* (+ #o100 *step-level*))
            (adjust-array-size *step-apply-p-array* (+ #o100 *step-level*)))
       mc (setf (aref *step-array* *step-level*) *step-form*)
          (setf (aref *step-apply-p-array* *step-level*) t)
          (if ( *step-level* *step-max*)
              (setq tem (step-cmdr *step-form* nil t t environment))
              (setq tem 'eval))
          (cond ((eq tem 'eval)
                 (setq *step-values*
                       (multiple-value-list (apply (car *step-form*) (cdr *step-form*)))))
                ((eq tem 'evalhook)
                 (setq *step-values*
                       (multiple-value-list
                         (let ((*evalhook* #'step-evalhook))
                           (apply (car *step-form*) (cdr *step-form*))))))
                ((ferror nil "Unknown function ~S" tem)))
       rl (setq *step-value* (setq val (car *step-values*)))
          (if ( *step-level* *step-max*)
              (setq tem (step-cmdr *step-form* *step-values* (neq tem 'eval) t environment))
              (setq tem 'eval))
          (when (neq *step-value* val)
            (return-from step-applyhook *step-value*))
       rt (cond ((null (cdr *step-values*))
                 (return-from step-applyhook (car *step-values*)))
                (t
                 (return-next-value (car *step-values*))
                 (setq *step-values* (cdr *step-values*))
                 (go rt)))))))

;;;; PRINT abbreviated spacewise rather than listwise

(defvar print-truncated)                        ;YECH

(defun terpri-if-insufficient-space (percent-width)
  (let ((x (truncate (* percent-width (send *standard-output* :inside-size)) 100.)))
    (and ( (send *standard-output* :read-cursorpos :pixel) x)
         (terpri))))

(defun print-truncated (sexp percent-width)
  (let ((print-truncated (truncate (* percent-width (send *standard-output* :inside-size))
                                   100.)))
    (catch 'print-truncated
      (prin1 sexp (closure '(print-truncated *standard-output*)
                           #'print-truncated-stream)))))

(defun print-elements-truncated (list truncation-percent-width terpri-percent-width)
  (dolist (element list)
    (terpri-if-insufficient-space terpri-percent-width)
    (print-truncated element truncation-percent-width)
    (write-char #\sp)))

(defun print-truncated-stream (op &optional arg1 &rest rest)
  (case op
    ((:tyo :write-char)
     (if ( (send *standard-output* :read-cursorpos :pixel)
            print-truncated)
         (throw 'print-truncated nil)
       (send *standard-output* (if (eq op ':tyo) :tyo :write-char) arg1)))
    (:which-operations '(:tyo :write-char))
    (otherwise
     (stream-default-handler 'print-truncated-stream op arg1 rest))))
